home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / cpp_libs / rwvector.lha / RWVector2.1 / src / mathpack / passb.f < prev    next >
Encoding:
Text File  |  1989-08-14  |  3.3 KB  |  123 lines
  1. *deck passb
  2.       subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
  3. C***BEGIN PROLOGUE  PASSB
  4. C***REFER TO CFFTB
  5. C***ROUTINES CALLED  (NONE)
  6. C***END PROLOGUE  PASSB
  7.       dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
  8.      1                c1(ido,l1,ip)          ,wa(1)      ,c2(idl1,ip),
  9.      2                ch2(idl1,ip)
  10. C***FIRST EXECUTABLE STATEMENT  PASSB
  11.       idot = ido/2
  12.       nt = ip*idl1
  13.       ipp2 = ip+2
  14.       ipph = (ip+1)/2
  15.       idp = ip*ido
  16. C
  17.       if (ido .lt. l1) go to 106
  18.       do 103 j=2,ipph
  19.          jc = ipp2-j
  20.          do 102 k=1,l1
  21.             do 101 i=1,ido
  22.                ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
  23.                ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  24.   101       continue
  25.   102    continue
  26.   103 continue
  27.       do 105 k=1,l1
  28.          do 104 i=1,ido
  29.             ch(i,k,1) = cc(i,1,k)
  30.   104    continue
  31.   105 continue
  32.       go to 112
  33.   106 do 109 j=2,ipph
  34.          jc = ipp2-j
  35.          do 108 i=1,ido
  36.             do 107 k=1,l1
  37.                ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
  38.                ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  39.   107       continue
  40.   108    continue
  41.   109 continue
  42.       do 111 i=1,ido
  43.          do 110 k=1,l1
  44.             ch(i,k,1) = cc(i,1,k)
  45.   110    continue
  46.   111 continue
  47.   112 idl = 2-ido
  48.       inc = 0
  49.       do 116 l=2,ipph
  50.          lc = ipp2-l
  51.          idl = idl+ido
  52.          do 113 ik=1,idl1
  53.             c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
  54.             c2(ik,lc) = wa(idl)*ch2(ik,ip)
  55.   113    continue
  56.          idlj = idl
  57.          inc = inc+ido
  58.          do 115 j=3,ipph
  59.             jc = ipp2-j
  60.             idlj = idlj+inc
  61.             if (idlj .gt. idp) idlj = idlj-idp
  62.             war = wa(idlj-1)
  63.             wai = wa(idlj)
  64.             do 114 ik=1,idl1
  65.                c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
  66.                c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc)
  67.   114       continue
  68.   115    continue
  69.   116 continue
  70.       do 118 j=2,ipph
  71.          do 117 ik=1,idl1
  72.             ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
  73.   117    continue
  74.   118 continue
  75.       do 120 j=2,ipph
  76.          jc = ipp2-j
  77.          do 119 ik=2,idl1,2
  78.             ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
  79.             ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
  80.             ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
  81.             ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
  82.   119    continue
  83.   120 continue
  84.       nac = 1
  85.       if (ido .eq. 2) return
  86.       nac = 0
  87.       do 121 ik=1,idl1
  88.          c2(ik,1) = ch2(ik,1)
  89.   121 continue
  90.       do 123 j=2,ip
  91.          do 122 k=1,l1
  92.             c1(1,k,j) = ch(1,k,j)
  93.             c1(2,k,j) = ch(2,k,j)
  94.   122    continue
  95.   123 continue
  96.       if (idot .gt. l1) go to 127
  97.       idij = 0
  98.       do 126 j=2,ip
  99.          idij = idij+2
  100.          do 125 i=4,ido,2
  101.             idij = idij+2
  102.             do 124 k=1,l1
  103.                c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
  104.                c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  105.   124       continue
  106.   125    continue
  107.   126 continue
  108.       return
  109.   127 idj = 2-ido
  110.       do 130 j=2,ip
  111.          idj = idj+ido
  112.          do 129 k=1,l1
  113.             idij = idj
  114.             do 128 i=4,ido,2
  115.                idij = idij+2
  116.                c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
  117.                c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  118.   128       continue
  119.   129    continue
  120.   130 continue
  121.       return
  122.       end
  123.